home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / cmlisp.em < prev    next >
Lisp/Scheme  |  1992-04-03  |  20KB  |  771 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10.  
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21.  
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42.  
  43.  
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107. (defmodule cmlisp (standard0 plural cmlisp-ll) ()
  108.   
  109.   (defclass mp-object ()
  110.     ((context
  111.       initarg context
  112.       reader  context)
  113.      (offset
  114.       initarg offset
  115.       reader  offset))
  116.     predicate mp-object-p)
  117.   
  118.   (defclass xec (mp-object)
  119.     ()
  120.     constructor (allocate-xec context offset)
  121.     predicate xecp)
  122.   
  123.   (defmethod generic-prin ((p xec) str)
  124.     (format str "#x(")
  125.     (mp-print (context p) (offset p) str)
  126.     (format str ")")
  127.     p)
  128.   
  129.   (defmethod generic-write ((p xec) str)
  130.     (format str "#x(")
  131.     (mp-print (context p) (offset p) str)
  132.     (format str ")")
  133.     p)
  134.   
  135. ; Most Actual operations on xecs are those done with the "everywhere"
  136. ; context of (on our machine) 512 elements. As we know we are always
  137. ; using this context we work with the offsets and the EverWhere-Context
  138. ; which is abbreviated to EW-Ctxt. We define some operations and contexts
  139. ; which work solely in this context and they have the EWC prefix. EveryWhere
  140. ; is used to distinguish "everywhere" xappings {->obj} from orfinary xappings
  141.  
  142.   (setq EW-Ctxt (mp-make-context 512))
  143.   ((setter the-context) EW-Ctxt)
  144.  
  145.   (defun Init-EveryWhere (MasPar-Config)
  146.     (let ((Ids (mp-make-plural EW-Ctxt)))
  147.       (labels ((recurse (n) 
  148.              (mp-set EW-Ctxt Ids n n)
  149.              (if (zerop n) Ids (recurse (- n 1)))))
  150.         (recurse MasPar-Config))))
  151.   
  152.   (setq EW-Ofst (Init-EveryWhere 512))
  153.  
  154.   (setq WhereNext 510)
  155.   (setq XectorLim 1)
  156.  
  157.   (setq EW-Nil (mp-bang EW-Ctxt ()))
  158.   (setq EW-Zero (mp-bang EW-Ctxt 0))
  159.   (setq EW-Unit (mp-bang EW-Ctxt 1))
  160.   (setq EW-Wild (mp-bang EW-Ctxt 9999))
  161.   
  162.   (defun EW-Times (a b)
  163.     (mp-bin-op EW-Ctxt a b 613))
  164.   
  165.   (defun EW-Minus (a b)
  166.     (mp-bin-op EW-Ctxt a b 611))
  167.   
  168.   (defun EW-Plus (a b)
  169.     (mp-bin-op EW-Ctxt a b     610))
  170.   
  171.   (defun EW-Scan-Plus (a)
  172.     (mp-scan-op EW-Ctxt a     610))
  173.  
  174.   (setq WA-Ofst (EW-Plus EW-Ofst EW-Zero))
  175.   (setq EW-Shift (mp-set EW-Ctxt (EW-Plus EW-Ofst EW-Unit) 511 0))
  176.  
  177. ; Below I have adopted the convention that any capitalised variable name 
  178. ; holds te offset of a xec with the EveryWhere context
  179.  
  180. ; where takes an object and returns a processor id (of sorts) which is
  181. ; used as the rendezvous address
  182.  
  183.   (defcondition no-more-PEs ())
  184.  
  185.   (defun where (o)
  186.     (let ((Here (EW-Plus EW-Zero EW-Zero)))
  187.       (cond 
  188.        ((and (eq (class-of o) integer) (< o WhereNext))
  189.     (if (> o XectorLim) (setq XectorLim o) o))
  190.        ((mp-if EW-Ctxt (mp-eq EW-Ctxt WA-Ofst (mp-bang EW-Ctxt o)))
  191.     (progn
  192.       (mp-assign EW-Ctxt Here EW-Ofst)
  193.       (mp-fi EW-Ctxt)
  194.       (mp-ref EW-Ctxt (mp-scan-op EW-Ctxt Here     660) 511)))
  195.        ((> WhereNext XectorLim)
  196.     (progn 
  197.       (mp-fi EW-Ctxt)
  198.       (mp-set EW-Ctxt WA-Ofst WhereNext o)
  199.       (setq WhereNext (- WhereNext 1))
  200.       (+ WhereNext 1)))
  201.        (t (progn (mp-fi EW-Ctxt)
  202.          (error "Exhausted PE Locations" no-more-PEs))))))
  203.  
  204.   (defun Intersect (Xecs)
  205.     (labels ((n-and (list-of-xecs)
  206.              (if (= (list-length list-of-xecs) 1) (car list-of-xecs)
  207.          (mp-and EW-Ctxt (car list-of-xecs)
  208.              (n-and (cdr list-of-xecs)))))
  209.          (n-car (list-of-xecs)
  210.            (if (cdr list-of-xecs) (n-car (cdr list-of-xecs)) ())
  211.            (mp-assign EW-Ctxt (car list-of-xecs)
  212.               (mp-car EW-Ctxt (car list-of-xecs)))))
  213.        (mp-if EW-Ctxt (if Xecs (n-and Xecs) EW-Ofst))
  214.        (if Xecs (n-car Xecs) ())
  215.        (EW-Plus EW-Unit EW-Zero)))
  216.   
  217.   (setq it eq)
  218.  
  219.   (defun reunite (Result Units)
  220.     (mp-else EW-Ctxt)
  221.     (mp-assign EW-Ctxt Result EW-Nil)
  222.     (mp-assign EW-Ctxt Units EW-Zero)
  223.     (mp-fi EW-Ctxt)
  224.     (let ((is-a (what-is-it Units))
  225.       (Enum (EW-Scan-Plus Units)))
  226.       (if (it is-a everywhere) (allocate-everywhere Result
  227.                             (mp-ref EW-Ctxt Result 0))
  228.     (let* ((new-ctx (mp-make-context (mp-ref EW-Ctxt Enum 511)))
  229.            (To (EW-Plus (mp-bang EW-Ctxt (cm-start new-ctx))
  230.                 (EW-Plus (EW-Minus Enum EW-Unit)
  231.                      (EW-Times EW-Wild
  232.                            (EW-Minus Units EW-Unit))))))
  233.       ((if (it is-a xector) allocate-xector allocate-xapping) new-ctx 
  234.        (mp-car new-ctx (cm-put EW-Ctxt EW-Ofst To new-ctx))
  235.        (mp-car new-ctx (cm-put EW-Ctxt Result To new-ctx)))))))
  236.  
  237.   (defun what-is-it (Units)
  238.     (cond
  239.      ((eq (mp-ref EW-Ctxt Units 511) 1) everywhere)
  240.      ((zerop (mp-ref EW-Ctxt Units 0))  xapping)
  241.      (t (let ((Sftd-Units 
  242.            (mp-set EW-Ctxt 
  243.                (mp-car EW-Ctxt (cm-put EW-Ctxt Units EW-Shift EW-Ctxt))
  244.                0 1)))
  245.       (mp-if EW-Ctxt (mp-eq EW-Ctxt Units EW-Unit))
  246.       (mp-if EW-Ctxt (mp-eq EW-Ctxt Sftd-Units EW-Unit))
  247.       (let ((is-a-xapping (mp-else EW-Ctxt)))
  248.         (mp-fi EW-Ctxt)
  249.         (mp-fi EW-Ctxt)
  250.         (if is-a-xapping xapping xector))))))
  251.  
  252. ; Xappings, the bit the user actually sees and works with and protects
  253. ; him from the nasty underlying operations
  254.  
  255.   (defclass xapping ()
  256.     ((context
  257.       initarg context
  258.       reader context)
  259.      (domain
  260.       initarg domain
  261.       reader domain)
  262.      (range
  263.       initarg range
  264.       accessor range))
  265.     predicate xappingp
  266.     constructor (allocate-xapping context domain range))
  267.  
  268.   (defun xapping-domain-ref (x i)
  269.     (mp-ref EW-Ctxt WA-Ofst (mp-ref (context x) (domain x) i)))
  270.  
  271.   (defun xapping-range-ref (x i)
  272.     (mp-ref (context x) (range x) i))
  273.  
  274.   (defun xapping-length (x)
  275.     (mp-length (context x)))
  276.  
  277.   (defmethod generic-write ((x xapping) str)
  278.     (let ((len (- (xapping-length x) 1)))
  279.       (labels ((print-pairs (i)
  280.              (format str "~a->~a" (xapping-domain-ref x i)
  281.              (xapping-range-ref x i))
  282.          (if (< i len) (progn (format str " ")
  283.                       (print-pairs (+ i 1))) ())))
  284.     (format str "#X(")
  285.     (print-pairs 0)
  286.     (format str ")"))))
  287.  
  288.   (defmethod generic-prin ((x xapping) str)
  289.     (let ((len (- (xapping-length x) 1)))
  290.       (labels ((print-pairs (i)
  291.              (format str "~a->~a" (xapping-domain-ref x i)
  292.              (xapping-range-ref x i))
  293.          (if (< i len) (progn (format str " ")
  294.                       (print-pairs (+ i 1))) ())))
  295.     (format str "#X(")
  296.     (print-pairs 0)
  297.     (format str ")"))))
  298.  
  299.   (defun list-to-xapping (pair-list)
  300.     (if (not (evenp (list-length pair-list)))
  301.       (error "Not an even number of elements" illegal-arg)
  302.       (let* ((new-context (mp-make-context (/ (list-length pair-list) 2)))
  303.          (new-domain  (mp-make-plural new-context))
  304.          (new-range   (mp-make-plural new-context)))
  305.     (labels ((recurse (pair-list i)
  306.            (if (cddr pair-list) (recurse (cddr pair-list) (+ i 1)) ())
  307.            (mp-set new-context new-domain i (where (car pair-list)))
  308.            (mp-set new-context new-range i (cadr pair-list))))
  309.         (progn 
  310.           (recurse pair-list 0)
  311.           (allocate-xapping new-context new-domain new-range))))))
  312.         
  313.   (defclass xector (xapping)
  314.     ()
  315.     predicate xectorp
  316.     constructor (allocate-xector context domain range))
  317.   
  318.   (defmethod generic-prin ((x xector) str)
  319.     (format str "#X[")
  320.     (mp-print (context x) (range x))
  321.     (format str "]")
  322.     x)
  323.  
  324.   (defmethod generic-write ((x xector) str)
  325.     (format str "#X[")
  326.     (mp-print (context x) (range x))
  327.     (format str "]")
  328.     x)
  329.  
  330.   (defcondition xector-too-big ())
  331.   
  332.   (defun list-to-xector (list)
  333.     (if (>= (list-length list) WhereNext)
  334.       (error "Xector to big to accomodate" xector-too-big)
  335.       (let* ((new-context (mp-make-context (list-length list)))
  336.          (new-domain  (mp-make-plural  new-context))
  337.          (new-range   (mp-make-plural  new-context)))
  338.     (if (< (list-length list) XectorLim) ()
  339.       (setq XectorLim (list-length list)))
  340.     (labels ((recurse (list i)
  341.            (if (cdr list) (recurse (cdr list) (+ i 1)) ())
  342.            (mp-set new-context new-domain i i)
  343.            (mp-set new-context new-range  i (car list))))
  344.       (progn 
  345.         (recurse list 0)
  346.         (allocate-xector new-context new-domain new-range))))))
  347.  
  348.   (defclass everywhere (xapping)
  349.     ()
  350.     predicate everywherep
  351.     constructor (allocate-everywhere domain range))
  352.  
  353.   (defmethod generic-prin ((x everywhere) str)
  354.     (format str "#X( ->~a)" (range x))
  355.     x)
  356.  
  357.   (defmethod generic-write ((x everywhere) str)
  358.     (format str "#X( ->~a)" (range x))
  359.     x)
  360.  
  361.   (defun rendezvous (x)
  362.     (if (everywherep x) (domain x)
  363.       (cm-put (context x) (range x) (domain x) EW-Ctxt)))
  364.  
  365.   (defun what-pe (x i)
  366.     (let ((EW-Pes (cm-put (context x) EW-Ofst (domain x) EW-Ctxt))
  367.       (EW-Pe (EW-Plus EW-Zero EW-Zero)))
  368.       (mp-if EW-Ctxt EW-Pes)
  369.       (mp-assign EW-Ctxt EW-Pes (mp-car EW-Ctxt EW-Pes))
  370.       (if (mp-if EW-Ctxt (mp-eq EW-Ctxt WA-Ofst (mp-bang EW-Ctxt i)))
  371.     (progn
  372.       (mp-assign EW-Ctxt EW-Pe EW-Pes)
  373.       (mp-fi EW-Ctxt)
  374.       (mp-fi EW-Ctxt)
  375.       (mp-ref EW-Ctxt (mp-scan-op EW-Ctxt EW-Pe     660) 511))
  376.     (progn
  377.       (mp-fi EW-Ctxt)
  378.       (mp-fi EW-Ctxt)
  379.       ()))))
  380.  
  381.   (defcondition out-of-range ())
  382.   (defcondition illegal-arg  ())
  383.  
  384.   (defun xref (x i)
  385.     (if (xappingp x) (let ((EW-I (what-pe x i)))
  386.                (if EW-I (mp-ref EW-Ctxt (range x) EW-I)
  387.              (error "Index not in range" out-of-range)))
  388.       (error "Arg 1 not a xapping" illegal-arg)))
  389.  
  390.   (defun xset (o x i)
  391.     (if (xappingp x) (let ((EW-I (what-pe x i)))
  392.                (if EW-I (progn (mp-set EW-Ctxt (range x) EW-I o) x)
  393.              (error "Index not in range" out-of-range)))
  394.       (error "Arg 2 not a xapping" illegal-arg)))
  395.  
  396.   (defun xmod (v x i)
  397.     (if (xappingp x) (let ((EW-Index (where i))
  398.               (EW-Range (rendezvous x)))
  399.               (mp-set EW-Ctxt EW-Range EW-Index (list v))
  400.               (mp-if EW-Ctxt EW-Range)
  401.               (mp-assign EW-Ctxt EW-Range (mp-car EW-Ctxt EW-Range))
  402.               (reunite EW-Range (EW-Plus EW-Unit EW-Zero)))
  403.       (error "Arg 2 not a xapping" illegal-arg)))
  404.  
  405. ; Primitives
  406. ; ==========
  407.  
  408.   (setq pfun-table (make-table))
  409.  
  410.   (defun add-pfun (name)
  411.      ((setter table-ref) pfun-table name 
  412.       (cons (last-function-name) (last-function-arglist))))
  413.  
  414.   (setq psetter-table (make-table))
  415.   
  416.   (defun add-psetter (name) 
  417.     ((setter table-ref) psetter-table name 
  418.      (cons (last-function-name))))
  419.  
  420.   (p-1-fn mp-un-op       620)
  421.   (add-pfun 'negate)
  422.   (p-2-fn mp-eq ())
  423.   (add-pfun 'eq)
  424.   (p-2-fn mp-cons ())
  425.   (add-pfun 'cons)
  426.   (p-1-fn mp-car ())
  427.   (add-pfun 'car)
  428.   (p-1-fn mp-cdr ())
  429.   (add-pfun 'cdr)
  430.   (p-1-fn mp-make-vector ())
  431.   (add-pfun 'make-vector)
  432.   (p-1-fn mp-vector-length ())
  433.   (add-pfun 'vector-length)
  434.   (p-2-fn mp-vector-ref ())
  435.   (add-pfun 'vector-ref)
  436.   (p-1-fn mp-test 2)
  437.   (add-pfun (quote consp))
  438.   (p-1-fn mp-test #x7fff)
  439.   (add-pfun (quote null))
  440.   (p-1-fn mp-test 1)
  441.   (add-pfun (quote intp))
  442.   (p-1-fn mp-test 4)
  443.   (add-pfun (quote floatp))
  444.   (p-1-fn mp-test 3)
  445.   (add-pfun (quote vectorp))
  446.   (p-2-fn mp-bin-op     610)
  447.   (add-pfun (quote binary-plus))
  448.   (p-2-fn mp-bin-op     610)
  449.   (add-pfun (quote +))
  450.   (p-2-fn mp-bin-op 611)
  451.   (add-pfun (quote binary-difference))
  452.   (p-2-fn mp-bin-op 611)
  453.   (add-pfun (quote -))
  454.   (p-2-fn mp-bin-op 613)
  455.   (add-pfun (quote binary-times))
  456.   (p-2-fn mp-bin-op 613)
  457.   (add-pfun (quote *))
  458.   (p-2-fn mp-bin-op 612)
  459.   (add-pfun (quote binary-divide))
  460.   (p-2-fn mp-bin-op 612)
  461.   (add-pfun (quote /))
  462.   (p-2-fn mp-rel-op     651)
  463.   (add-pfun (quote binary-gt))
  464.   (p-2-fn mp-rel-op     651)
  465.   (add-pfun (quote >))
  466.   (p-2-fn mp-rel-op     650)
  467.   (add-pfun (quote binary-lt))
  468.   (p-2-fn mp-rel-op     650)
  469.   (add-pfun (quote <))
  470.   (p-2-fn mp-bin-op 614)
  471.   (add-pfun (quote remainder))
  472.   (p-2-fn mp-and ())
  473.   (add-pfun (quote and))
  474.   (p-2-fn mp-or ())
  475.   (add-pfun (quote or))
  476.  
  477.   (p-3-fn mp-vector-set ())
  478.   (add-psetter (quote vector-ref))
  479.   (p-2-fn mp-rplaca ())
  480.   (add-psetter (quote car))
  481.   (p-2-fn mp-rplacd ())
  482.   (add-psetter (quote cdr))
  483.  
  484. ; There are a few lisp functions who work in parallel - this is a hack!
  485.  
  486.   ((setter table-ref) pfun-table 'progn (cons 'progn ()))
  487.  
  488. ; Alpha
  489. ; =====
  490.  
  491.   (defun rewire (form)
  492.     (cond 
  493.      ((consp form)
  494.       (cond
  495.        ((eq (car form) 'quote) (rewire (cdr form)))
  496.        ((eq (car form) (car function-name)) (cons (cadr function-name)
  497.                           (rewire (cdr form))))
  498.        ((eq (car form) 'bullet) (cadr form))
  499.        ((eq (car form) 'setter) (table-ref psetter-table (cadr form)))
  500.        ((eq (car form) 'if) (alpha-if (cadr form) (caddr form) (cadddr form)))
  501.        (t (cons (if (car form) (rewire (car form)) EW-Nil)
  502.         (rewire (cdr form))))))
  503.      ((numberp form) (mp-bang EW-Ctxt form))
  504.      (form (if (memq form arg-list) (list 'mp-bang 'EW-Ctxt form)
  505.          (let ((alpha-fun (table-ref pfun-table form)))
  506.            (if alpha-fun (car alpha-fun) (list 'mp-bang 'EW-Ctxt form)))))
  507.      (t ())))
  508.  
  509.   (defun alpha-if (bool then else)
  510.     (list 'let '((if-result (mp-make-plural EW-Ctxt)))
  511.       (list 'progn
  512.         (list 'if (list 'mp-if 'EW-Ctxt (rewire bool))
  513.               (list 'mp-assign 'EW-Ctxt 'if-result (rewire then)) ())
  514.         (list 'if (list 'mp-else 'EW-Ctxt)
  515.               (list 'mp-assign 'EW-Ctxt 'if-result (rewire else)) ())
  516.         '(mp-fi EW-Ctxt)
  517.         'if-result)))
  518.  
  519.   (defun bulletify (name)
  520.     (list 'bullet name))
  521.  
  522.   (defun Bind-args (args)
  523.     (labels ((make-binding (arg-name)
  524.            (list arg-name (list 'rendezvous arg-name)))
  525.          (recurse (list-of-args)
  526.            (if list-of-args (cons (make-binding (car list-of-args))
  527.                       (recurse (cdr list-of-args))) ())))
  528.       (append (recurse args)
  529.           (list (list 'Units (list 'Intersect 
  530.                        (cons 'list args)))))))
  531.  
  532.   (defun find-xappings (form)
  533.     (if (consp form) 
  534.       (if (eq (car form) 'bullet) 
  535.     (if ((setter table-ref) xapping-table (cadr form) t) ()
  536.       (setq xapping-list (cons (cadr form) xapping-list)))
  537.     (progn (find-xappings (car form))
  538.            (find-xappings (cdr form))))
  539.       xapping-list))
  540.  
  541. ; (alpha if) is too compilacate and has to be created as a special case
  542.  
  543.   (defmacro alpha (form)
  544.     (setq xapping-table (make-table))
  545.     (setq xapping-list ())
  546.     (setq arg-list ())
  547.     (setq function-name '(none))
  548.     (if (and (consp form) (not (eq (car form) 'setter)))
  549.       (cond 
  550.        ((eq (car form) `lambda)
  551.     (let ((args (cadr form)) (body (caddr form)))
  552.       (setq arg-list args)
  553.       `(lambda ,args
  554.          (let* ,(Bind-args (find-xappings body))
  555.            (reunite ,(rewire body) Units)))))
  556.        ((eq (car form) `defun)
  557.     (let ((args (caddr form)) (body (caddr (cdr form))))
  558.       (setq function-name (list (cadr form) (gensym)))
  559.       ((setter table-ref) pfun-table (car function-name)
  560.        (cons (cadr function-name) (caddr form)))
  561.       `(defun ,(cadr function-name) ,args
  562.          ,(rewire body))))
  563.     (t 
  564.      `((lambda ()
  565.          (let* ,(Bind-args (find-xappings form))
  566.            (reunite ,(rewire form) Units))))))
  567.       (let ((pfun (if (consp form) (table-ref psetter-table (cadr form))
  568.             (table-ref pfun-table form))))
  569.     (if pfun (let ((args (cdr pfun)))
  570.            `(lambda ,args
  571.               (let* ,(Bind-args args)
  572.             (reunite ,(rewire (cons form (mapcar bulletify args)))
  573.                  Units))))
  574.       (allocate-everywhere (mp-bang EW-Ctxt form) form)))))
  575.  
  576. ; Beta
  577. ; ====
  578.  
  579.  
  580.   (defun Build-map (index)
  581.     (let ((Map (mp-make-plural EW-Ctxt))
  582.       (len (- (mp-length (context index)) 1)))
  583.       (labels ((recurse (i)
  584.          (if (< i len) (recurse (+ i 1)) ())
  585.          (mp-if EW-Ctxt 
  586.             (mp-eq EW-Ctxt EW-Ofst
  587.                    (mp-bang EW-Ctxt 
  588.                     (where (xapping-range-ref index i)))))
  589.          (mp-assign EW-Ctxt Map
  590.                 (mp-cons EW-Ctxt 
  591.                      (mp-bang EW-Ctxt i) Map))
  592.          (mp-fi EW-Ctxt)))
  593.         (recurse 0)
  594.     Map)))
  595.  
  596.   (defun list-tail (l) (list-ref l (- (list-length l) 1)))
  597.  
  598.   (defun b-rewire (form)
  599.     (cond 
  600.      ((consp form)
  601.       (cond
  602.        ((eq (car form) 'quote) (b-rewire (cdr form)))
  603.        ((eq (car form) 'bullet) (cadr form))
  604.        (t (cons (if (car form) (b-rewire (car form)) EW-Nil)
  605.         (b-rewire (cdr form))))))
  606.      ((numberp form) (mp-bang EW-Ctxt form))
  607.      (form (if (memq form arg-list) form
  608.          (let ((alpha-fun (table-ref pfun-table form)))
  609.            (if alpha-fun (car alpha-fun) (list 'mp-bang 'EW-Ctxt form)))))
  610.      (t ())))
  611.  
  612.   (setq Botch (mp-bang EW-Ctxt 'botch))
  613.  
  614.   (defun p-default-combinator (a b) Botch)
  615.  
  616.   (defun beta-internal (Range Map with)
  617.     (mp-if EW-Ctxt Range)
  618.     (mp-assign EW-Ctxt Range (mp-car EW-Ctxt Range))
  619.     (mp-fi EW-Ctxt)
  620.     (let ((Moved (mp-move EW-Ctxt Range EW-Ctxt Map))
  621.       (Result (mp-make-plural EW-Ctxt))
  622.       (Units (EW-Plus EW-Zero EW-Zero)))
  623.       (mp-if EW-Ctxt Moved)
  624.       (mp-assign EW-Ctxt Units EW-Unit)
  625.       (labels ((recurse (List CdrList)
  626.          (if (mp-if EW-Ctxt CdrList) 
  627.            (mp-assign EW-Ctxt Result
  628.                   (with (mp-car EW-Ctxt List)
  629.                     (recurse CdrList 
  630.                          (mp-cdr EW-Ctxt CdrList)))) ())
  631.          (mp-else EW-Ctxt)
  632.          (mp-assign EW-Ctxt Result (mp-car EW-Ctxt List))
  633.          (mp-fi EW-Ctxt)
  634.          Result))
  635.      (reunite (recurse Moved (mp-cdr EW-Ctxt Moved)) Units))))
  636.  
  637. ; Modification to mp-move - plural has to be pre-allocated !
  638.  
  639.   (defun beta-internal (Range Map with)
  640.     (mp-if EW-Ctxt Range)
  641.     (mp-assign EW-Ctxt Range (mp-car EW-Ctxt Range))
  642.     (mp-fi EW-Ctxt)
  643.     (let ((Moved (mp-make-plural EW-Ctxt))
  644.       (Result (mp-make-plural EW-Ctxt))
  645.       (Units (EW-Plus EW-Zero EW-Zero)))
  646.       (mp-move EW-Ctxt Range EW-Ctxt Map Moved)
  647.       (mp-if EW-Ctxt Moved)
  648.       (mp-assign EW-Ctxt Units EW-Unit)
  649.       (labels ((recurse (List CdrList)
  650.          (if (mp-if EW-Ctxt CdrList) 
  651.            (mp-assign EW-Ctxt Result
  652.                   (with (mp-car EW-Ctxt List)
  653.                     (recurse CdrList 
  654.                          (mp-cdr EW-Ctxt CdrList)))) ())
  655.          (mp-else EW-Ctxt)
  656.          (mp-assign EW-Ctxt Result (mp-car EW-Ctxt List))
  657.          (mp-fi EW-Ctxt)
  658.          Result))
  659.      (reunite (recurse Moved (mp-cdr EW-Ctxt Moved)) Units))))
  660.  
  661.  
  662.   (defun s-default-combinator (a b) 'botch)
  663.  
  664.   (defun reduce (xapp with)
  665.     (let ((len (- (mp-length (context xapp)) 1))
  666.       (ctxt (context xapp))
  667.       (ofst (range xapp)))
  668.       (labels ((recurse (i)
  669.         (if (= i len) (mp-ref ctxt ofst i)
  670.           (with (mp-ref ctxt ofst i) (recurse (+ i 1))))))
  671.     (recurse 0))))
  672.  
  673.   (defmacro beta args
  674.     (let* ((s-form (if (= (list-length args) 0) s-default-combinator
  675.              (car args)))
  676.        (p-form (if (= (list-length args) 0) p-default-combinator
  677.              (progn
  678.                (setq xapping-table (make-table))
  679.                (setq xapping-list ())
  680.                (setq arg-list ())
  681.                (if (consp (car args))
  682.                (let ((args (cadar args)) (body (caddar args)))
  683.                  (setq arg-list args)
  684.                  (list 'lambda args (b-rewire body)))
  685.              (car (table-ref pfun-table (car args))))))))
  686.       `(lambda args
  687.      (let ((s-with ,s-form)
  688.            (p-with ,p-form))
  689.        (if (cdr args)
  690.          (beta-internal (rendezvous (car args))
  691.                 (Build-map (cadr args)) p-with)
  692.          (reduce (car args) s-with))))))
  693.  
  694.   
  695. )
  696.  
  697.  
  698. (defmacro compile (form)
  699.   (if (consp form)
  700.     (if (eq (car form) 'alpha) (macroexpand `,form)
  701.       (cons (compile (car form)) (compile (cdr form))))
  702.     form))
  703.  
  704. ;; if 
  705.  
  706. (alpha (if (< (bullet xap1) 5) (bullet xap1) (- 5 (bullet xap1))))
  707.  
  708.    (let ((if-result (mp-make-plural EW-Ctxt)))
  709.      (progn
  710.        (if (mp-if EW-Ctxt 
  711.  
  712.  
  713. (setq simon (list-to-xapping '(cap 12 perihelion 3 BUCS 3)))
  714. (setq don (list-to-xapping '(micro-automation 12 perihelion 30)))
  715. (setq duncan (list-to-xapping '(IBM 12 perihelion 24)))
  716. (setq bob (list-to-xapping '(micro-automation 18 Melbourne-Uni 3 BUCS 4)))
  717.  
  718.  
  719.  
  720. (alpha-if '(< (bullet simon) (bullet don)) '(cons (bullet simon) (bullet don))
  721.       '(cons (bullet don) (bullet simon)))
  722.  
  723.     
  724. (macroexpand (alpha (if (< (bullet simon) (bullet don))
  725.             (cons (bullet simon) (bullet don))
  726.             (cons (bullet don) (bullet simon)))))
  727.  
  728. (macroexpand (p-if ((alpha <) don simon) ((alpha cons) don simon) ((alpha cons) simon don)))
  729.  
  730.   (defmacro p-if (bool then else)
  731.     (setq xapping-table (make-table))
  732.     (setq xapping-list ())
  733.     (setq arg-list ())
  734.     `(let* ((bool-value (rendezvous ,bool))
  735.         (bool (let ((tmp (mp-assign EW-Ctxt 
  736.                     (mp-make-plural EW-Ctxt) bool-value)))
  737.             (mp-if EW-Ctxt bool)
  738.             (mp-assign EW-Ctxt bool (mp-car EW-Ctxt bool-value))
  739.             (mp-fi EW-Ctxt)))
  740.         (then (if (mp-if EW-Ctxt bool) (rendezvous ,then) EW-Nil))
  741.         (else (if (mp-else EW-Ctxt) (rendezvous ,else) EW-Nil))
  742.         (Units (Intersect (list bool then else))))
  743.        (reunite (let ((if-result (mp-make-plural EW-Ctxt)))
  744.           (mp-if EW-Ctxt bool) 
  745.           (mp-assign EW-Ctxt if-result then)
  746.           (mp-else EW-Ctxt)
  747.           (mp-assign EW-Ctxt if-result else)) Units)))
  748.     
  749.  
  750.                
  751. (defprim p-list-length (p-list)
  752.   (if p-list (+ (p-list-length (cdr p-list)) 1)
  753.     0))
  754.  
  755. (defun p-list-length (p-list)
  756.   (if (mp-if EW-Ctxt p-list) 
  757.     ((lambda (a b) (mp-bin-op EW-Ctxt a b 610))
  758.      (p-list-length ((lambda (a) (mp-cdr EW-Ctxt a)) p-list))
  759.      (mp-bang EW-Ctxt 1))))
  760.  
  761.  
  762. ; This is very strange I mean list-length is now parallel so it has
  763. ; to be bulleted - or is it?
  764.  
  765.  
  766.  
  767.  
  768.  
  769.  
  770.  
  771.